home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / SORT.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  4.5 KB  |  140 lines
  1. ; SORT.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*            Destructive Sort! Routine            *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: David Bartley        Date: Jan 1987            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22. ; MERGE-SORT!  is adapted from an algorithm contributed to TI by Dr
  23. ; Alexander Stepanov of Polytechnic Institute of New York CS Dept, 30
  24. ; October 1985.  Tests show it to take 60% of the time of the old PC
  25. ; Scheme SORT!  for lists.  It is also faster than two different imple-
  26. ; mentations of Quicksort, so we use it to sort both vectors and lists.
  27.  
  28. ; (Performance figures given above are based on timings using PC Scheme
  29. ; and should be remeasured for other implementations.)
  30.  
  31. (define (sort! obj . rest)
  32.   (letrec
  33.     ((merge-sort!                ; merge-sort! (for lists)
  34.        (lambda (L less?)
  35.      (listify! L)
  36.      (par-reduce less? L)))
  37.  
  38.      (listify!
  39.        (lambda (L)
  40.          (when (pair? L)
  41.                (set-car! L (cons (car L) '()))
  42.                (listify! (cdr L)))))
  43.  
  44.      (merge!
  45.        (lambda (less? L1 L2)
  46.          (if (less? (car L1) (car L2))
  47.              (merge-tail less? (cdr L1) L2 L1 L1)
  48.              (merge-tail less? L1 (cdr L2) L2 L2))))
  49.  
  50.      (merge-tail
  51.        (lambda (less? L1 L2 result last)
  52.          (cond ((null? L1)
  53.                 (set-cdr! last L2)
  54.                 result)
  55.                ((null? L2)
  56.                 (set-cdr! last L1)
  57.                 result)
  58.                ((less? (car L1) (car L2))
  59.                 (set-cdr! last L1)
  60.                 (merge-tail less? (cdr L1) L2 result L1))
  61.                (else
  62.                 (set-cdr! last L2)
  63.                 (merge-tail less? L1 (cdr L2) result L2)))))
  64.  
  65.      (par-reduce
  66.        (lambda (less? list)
  67.          (if (null? (cdr list))
  68.              (car list)
  69.              (par-reduce less? (step-reduce less? list list)))))
  70.  
  71.      (step-reduce
  72.        (lambda (less? list L)
  73.          (if (null? (cdr L))
  74.              list
  75.              (let ((next (cddr L)))
  76.                (set-car! L (merge! less? (car L)(cadr L)))
  77.                (set-cdr! L next)
  78.                (step-reduce less? list next)))))
  79.      )
  80.     (let ((less? (or (and rest (car rest))
  81.              %sort-less?)))
  82.       (cond ((vector? obj)     (list->vector (merge-sort! (vector->list obj) less?)))
  83.             ((null? obj)       obj)
  84.             ((not (pair? obj)) (%error-invalid-operand 'SORT! obj))
  85.             ((null? (cdr obj)) obj)
  86.             (else           (merge-sort! obj less?))))))
  87.  
  88. ; number < char < string < symbol < list < vector
  89.  
  90. (define %sort-less?                    ; %SORT-LESS?
  91.   (letrec
  92.    ((type-of
  93.      (lambda (obj)
  94.        (cond ((or (null? obj) (pair? obj)) 4)
  95.          ((symbol? obj) 3)
  96.          ((vector? obj) 5)
  97.          ((string? obj) 2)
  98.          ((char? obj) 1)
  99.          ((number? obj) 0)
  100.          (else 42))))
  101.     (symbol-less
  102.      (lambda (obj1 obj2)
  103.        (string<? (symbol->string obj1)(symbol->string obj2))))
  104.     (list-less
  105.      (lambda (obj1 obj2)
  106.        (cond ((null? obj2) #F)
  107.          ((null? obj1) #T)
  108.          ((less (car obj1)(car obj2)) #T)
  109.          ((less (car obj2) (car obj1)) #F)
  110.          (else (less (cdr obj1) (cdr obj2))))))
  111.     (vector-less
  112.      (lambda (v1 v2)
  113.        (let ((l1 (vector-length v1))
  114.          (l2 (vector-length v2)))
  115.      (let loop ((i1 0)(i2 0))
  116.           (cond ((= i2 l2) #F)
  117.             ((= i1 l1) #T)
  118.             ((less (vector-ref v1 i1) (vector-ref v2 i2))
  119.              #T)
  120.             ((less (vector-ref v2 i2) (vector-ref v1 i1))
  121.              #F)
  122.             (else
  123.              (loop (add1 i1) (add1 i2))))))))
  124.     (less
  125.      (lambda (obj1 obj2)
  126.        (let ((t1 (type-of obj1))
  127.          (t2 (type-of obj2)))
  128.      (cond ((< t1 t2) #T)
  129.            ((> t1 t2) #F)
  130.            (else (case t1
  131.                ((0) (< obj1 obj2))
  132.                ((1) (char<? obj1 obj2))
  133.                ((2) (string<? obj1 obj2))
  134.                ((3) (symbol-less obj1 obj2))
  135.                ((4) (list-less obj1 obj2))
  136.                ((5) (vector-less obj1 obj2))
  137.                (else #T))))))))
  138.    (lambda (obj1 obj2)
  139.      (less obj1 obj2))))
  140.